home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / utils / ted / ted.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-10-02  |  20.4 KB  |  768 lines
  1. {───────────────────────────────────────────────────────────────────────────}
  2. {  FFFF OOOO N  N TTTT   EEEE DDD  I TTTT OOOO RRRR    COPYWRONG (C)  1994  }
  3. {  F    O  O NN N  T     EEE  D  D I  T   O  O R  R    BY MARCIN JASKOWIAK  }
  4. {  FFFF O  O N NN  T     E    D  D I  T   O  O RRR     AKA PARADiSE         }
  5. {  F    OOOO N  N  T     EEEE DDD  I  T   OOOO R  R    VERSION 1.0          }
  6. {───────────────────────────────────────────────────────────────────────────}
  7. PROGRAM TED;
  8.  
  9. USES CRT,DOS,GIF;
  10. {───────────────────────────────────────────────────────────────────────────}
  11. CONST
  12.  HEADER  : ARRAY [1..20] OF BYTE =(254,84,69,68,254,57,52,254,80,65,
  13.                                    82,65,68,105,83,69,254,00,00,07);
  14.  ENTER   = 00013;
  15.  ESC     = 00027;
  16.  F1      = 15104;
  17.  F2      = 15360;
  18.  F3      = 15616;
  19.  F4      = 15872;
  20.  F5      = 16128;
  21.  F6      = 16384;
  22.  F7      = 16640;
  23.  F8      = 16896;
  24.  F9      = 17152;
  25.  F10     = 17408;
  26.  ALTF1   = 26624;
  27.  ALTF2   = 26880;
  28.  ALTF3   = 27136;
  29.  ALTF4   = 27392;
  30.  ALTF5   = 27648;
  31.  ALTF6   = 27904;
  32.  ALTF7   = 28160;
  33.  ALTF8   = 28416;
  34.  ALTF9   = 28672;
  35.  ALTF10  = 28928;
  36.  HOMEK   = 18176;
  37.  UPK     = 18432;
  38.  PGUPK   = 18688;
  39.  LEFTK   = 19200;
  40.  RIGHTK  = 19712;
  41.  ENDK    = 20224;
  42.  DOWNK   = 20480;
  43.  PGDNK   = 20736;
  44.  INSK    = 20992;
  45.  DELK    = 21248;
  46.  CTRLK   = 29440;
  47.  CTRRK   = 29696;
  48.  CTRUK   = 18688;
  49.  CTRDK   = 20736;
  50.  ALTX    = 11520;
  51. TYPE
  52.  MOUSESHAPE     = ARRAY [1..100,1..100] OF BYTE;
  53.  TSCREEN        = ARRAY [0..63999] OF BYTE;
  54.  PSCREEN        = ^TSCREEN;
  55. CONST
  56.  MMY     : WORD = 20;
  57.  MMX     : WORD = 20;
  58.  Q       = 255;
  59. VAR
  60.  FONT           : ARRAY [0..255,0..15] OF BYTE;
  61.  MOUSE          : BOOLEAN;
  62.  KEY            : WORD;
  63.  QUIT,MOUSEHIDE : BOOLEAN;
  64.  XCHAR,YCHAR    : BYTE;
  65.  POSX,POSY,X,Y  : WORD;
  66.  MX,MY,MB,OX,OY : WORD;
  67.  LASTCH         : CHAR;
  68.  BACKM,MOUSEC   : MOUSESHAPE;
  69.  TEMP           : ARRAY [1..10000] OF BYTE;
  70.  PALETTE        : ARRAY [0..255,1..3] OF BYTE;
  71.  BITMAP         : PSCREEN;
  72.  S,N            : STRING;
  73.  CHARS          : ARRAY [' '..']'] OF POINTER;
  74.  CHARSDATA      : ARRAY [' '..']',1..3] OF BYTE;
  75. {───────────────────────────────────────────────────────────────────────────}
  76. PROCEDURE INITVGA; ASSEMBLER; { INITIALIZE VGA CARD MODE 13H }
  77. ASM
  78.  MOV AX,0013H
  79.  INT 10H
  80. END;
  81. {───────────────────────────────────────────────────────────────────────────}
  82. PROCEDURE CLOSEVGA; ASSEMBLER; { CLOSE VGA MODE AND SET TEXT }
  83. ASM
  84.  MOV AX,0003H
  85.  INT 10H
  86. END;
  87. {───────────────────────────────────────────────────────────────────────────}
  88. FUNCTION ISMOUSE: BOOLEAN; { CHECK IF MOUSE ACTIVE }
  89. VAR IS: WORD;
  90. BEGIN
  91.  ASM
  92.   XOR AX,AX
  93.   INT 33H
  94.   MOV IS,AX
  95.  END;
  96.  IF IS=0 THEN ISMOUSE:=FALSE
  97.  ELSE ISMOUSE:=TRUE;
  98. END;
  99. {───────────────────────────────────────────────────────────────────────────}
  100. PROCEDURE MOUSEPOS(VAR X,Y,BUTTON: WORD); { RETURN MOUSE POS AND BUTTON STAT }
  101. VAR R: REGISTERS;
  102. BEGIN
  103.  R.AX:=3;
  104.  INTR($33,R);
  105.  X:=R.CX;
  106.  Y:=R.DX;
  107.  IF R.BX=4 THEN BUTTON:=3 ELSE BUTTON:=R.BX;
  108.  X:=X DIV 2;
  109. END;
  110. {───────────────────────────────────────────────────────────────────────────}
  111. PROCEDURE SETCOLOR(NR,R,G,B: BYTE); ASSEMBLER; { SET RGB VAL TO COLOR NR }
  112. ASM
  113.  MOV DX,3C8H
  114.  MOV AL,NR
  115.  OUT DX,AL
  116.  INC DX
  117.  MOV AL,R
  118.  OUT DX,AL
  119.  MOV AL,G
  120.  OUT DX,AL
  121.  MOV AL,B
  122.  OUT DX,AL
  123. END;
  124. {───────────────────────────────────────────────────────────────────────────}
  125. FUNCTION GETKEY: WORD; { RETURN PRESSED KEY }
  126. VAR CH: CHAR;
  127. BEGIN
  128.  CH:=READKEY;
  129.  IF ORD(CH)=0 THEN GETKEY:=WORD(ORD(READKEY)) SHL 8
  130.               ELSE GETKEY:=ORD(CH);
  131.  LASTCH:=CH;
  132. END;
  133. {───────────────────────────────────────────────────────────────────────────}
  134. PROCEDURE PUTPIX(X,Y : INTEGER; C: BYTE); ASSEMBLER; { PLOT PIXEL AT (X,Y) }
  135. ASM
  136.  MOV   AX, 0A000H
  137.  MOV   ES, AX
  138.  MOV   AX, 320
  139.  MUL   Y
  140.  ADD   AX, X
  141.  MOV   DI, AX
  142.  MOV   AL, C
  143.  STOSB
  144. END;
  145. {───────────────────────────────────────────────────────────────────────────}
  146. FUNCTION GETPIX(X,Y : INTEGER): BYTE; ASSEMBLER; { GET A PIXEL FROM (X,Y) }
  147. ASM
  148.  MOV   AX, 0A000H
  149.  MOV   ES, AX
  150.  MOV   AX, 320
  151.  MUL   Y
  152.  ADD   AX, X
  153.  MOV   DI, AX
  154.  LODSB
  155. END;
  156. {───────────────────────────────────────────────────────────────────────────}
  157. PROCEDURE PUTPIX2(X,Y: INTEGER; C: BYTE); { MEMORY PUT PIXEL PROC }
  158. BEGIN
  159.  MEM[$A000:Y*320+X]:=C;
  160. END;
  161. {───────────────────────────────────────────────────────────────────────────}
  162. PROCEDURE RECTANGLE(X1,Y1,X2,Y2: INTEGER; C: BYTE); { DRAW A RECTANGLE }
  163. VAR Z: INTEGER;
  164. BEGIN
  165.  FOR Z:=X1 TO X2 DO
  166.  BEGIN
  167.   PUTPIX(Z,Y1,C);
  168.   PUTPIX(Z,Y2,C);
  169.  END;
  170.  FOR Z:=Y1 TO Y2 DO
  171.  BEGIN
  172.   PUTPIX2(X1,Z,C);
  173.   PUTPIX2(X2,Z,C);
  174.  END;
  175. END;
  176. {───────────────────────────────────────────────────────────────────────────}
  177. PROCEDURE RECTANGLE2(X1,Y1,X2,Y2: INTEGER; C: BYTE); { DRAW A RECTANGLE #2 }
  178. VAR Z: INTEGER;
  179. BEGIN
  180.  FOR Z:=X1 TO X2 DO
  181.  IF ODD(Z) THEN BEGIN
  182.   PUTPIX(Z,Y1,C);
  183.   PUTPIX(Z,Y2,C);
  184.  END;
  185.  FOR Z:=Y1 TO Y2 DO
  186.  IF ODD(Z) THEN BEGIN
  187.   PUTPIX2(X1,Z,C);
  188.   PUTPIX2(X2,Z,C);
  189.  END;
  190. END;
  191. {───────────────────────────────────────────────────────────────────────────}
  192. PROCEDURE LOADFONT;
  193. VAR FONTFILE: FILE;
  194.     CHNUM: BYTE;
  195.     CRAP: ARRAY[0..15] OF BYTE;
  196. PROCEDURE ROMFONT;
  197. VAR F8X8OFS,F8X8SEG: WORD;
  198. BEGIN
  199.  ASM
  200.   PUSH BP
  201.   MOV  AH,11H
  202.   MOV  AL,30H
  203.   MOV  BH,06H
  204.   INT  10H
  205.   MOV  AX,BP
  206.   POP  BP
  207.   MOV  F8X8OFS,AX
  208.   MOV  F8X8SEG,ES
  209.  END;
  210.  MOVE(MEM[F8X8SEG:F8X8OFS],FONT,256*16)
  211. END;
  212. BEGIN
  213.  ASSIGN(FONTFILE,'TED.FNT');
  214.  {$I-}
  215.  RESET(FONTFILE,1);
  216.  IF IORESULT<>0 THEN ROMFONT
  217.  ELSE
  218.  FOR CHNUM:=0 TO 255 DO
  219.  BEGIN
  220.   BLOCKREAD(FONTFILE,FONT[CHNUM,0],16);
  221.   BLOCKREAD(FONTFILE,CRAP,16);
  222.  END;
  223.  {$I+}
  224. END;
  225. {───────────────────────────────────────────────────────────────────────────}
  226. PROCEDURE WRITEXY(TEKST: STRING; X,Y: INTEGER; C: BYTE); { PRINT TEXT AT X,Y }
  227. VAR TX,TY: WORD; IZ: BYTE;
  228. BEGIN
  229.  FOR IZ:=1 TO LENGTH(TEKST) DO
  230.  FOR TY:=0 TO 15 DO
  231.  FOR TX:=0 TO 7 DO
  232.   IF FONT[ORD(TEKST[IZ]),TY] AND ($80 SHR TX)<>0 THEN
  233.   PUTPIX(X+TX+(IZ-1)*10,Y+TY,C);
  234. END;
  235. {───────────────────────────────────────────────────────────────────────────}
  236. PROCEDURE BAR(X1,Y1,X2,Y2: INTEGER; COLOR: BYTE); ASSEMBLER; { BAR BY WELTI }
  237. VAR I,H,ENDE : INTEGER;
  238. ASM
  239.  MOV   AX, X2
  240.  CMP   AX, X1
  241.  JAE   @L1
  242.  XCHG  X1, AX
  243.  XCHG  X2, AX
  244.  XCHG  X1, AX
  245.  @L1:
  246.  MOV   AX, Y2
  247.  CMP   AX, Y1
  248.  JAE   @L2
  249.  XCHG  Y1, AX
  250.  XCHG  Y2, AX
  251.  XCHG  Y1, AX
  252.  @L2:
  253.  MOV   AX, X2
  254.  MOV   ENDE, AX
  255.  MOV   CX, Y2
  256.  SUB   CX, Y1
  257.  INC   CX
  258.  MOV   AX, 0A000H
  259.  MOV   ES, AX
  260.  MOV   AX, 320
  261.  MUL   Y1
  262.  ADD   AX, X1
  263.  MOV   DI, AX
  264.  MOV   DX, X2
  265.  SUB   DX, X1
  266.  INC   DX
  267.  MOV   AH, COLOR
  268.  MOV   AL, COLOR
  269.  @FORSCHLEIFE:
  270.  MOV  BX, X1
  271.  CMP  DX, 1
  272.  JE   @WHILE2
  273.  @WHILE1:
  274.  STOSW
  275.  ADD   BX, 2
  276.  CMP   BX, ENDE
  277.  JB @WHILE1
  278.  MOV  H, DX
  279.  AND  H, 1
  280.  CMP  H, 1
  281.  JNE  @GERADE
  282.  @WHILE2:
  283.  STOSB
  284.  @GERADE:
  285.  ADD   DI, 320
  286.  SUB   DI, DX
  287.  LOOP @FORSCHLEIFE
  288. END;
  289. {───────────────────────────────────────────────────────────────────────────}
  290. PROCEDURE PUTMOUSE(X,Y: INTEGER; MC: MOUSESHAPE); { DRAW MOUSE CURSOR }
  291. VAR TX,TY: INTEGER;
  292. BEGIN
  293.  FOR TY:=1 TO MMY DO
  294.   FOR TX:=1 TO MMX DO
  295.   BEGIN
  296.    MEM[$A000:(Y+TY-1)*320+X+TX-1]:=MC[TY,TX];
  297.   END;
  298. END;
  299. {───────────────────────────────────────────────────────────────────────────}
  300. PROCEDURE GETMOUSE(X,Y: INTEGER; VAR MC: MOUSESHAPE); { GET MOUSE CURSOR }
  301. VAR TX,TY: INTEGER;
  302. BEGIN
  303.  FOR TY:=1 TO MMY DO
  304.   FOR TX:=1 TO MMX DO
  305.   BEGIN
  306.    MC[TY,TX]:=MEM[$A000:(Y+TY-1)*320+X+TX-1];
  307.   END;
  308. END;
  309. {───────────────────────────────────────────────────────────────────────────}
  310. PROCEDURE SETUPMOUSE; { INITIALIZE VGA MOUSE }
  311. BEGIN
  312.  MOUSEHIDE:=FALSE;
  313.  MOUSEPOS(OX,OY,MB);
  314.  GETMOUSE(OX,OY,BACKM);
  315.  MOUSEPOS(MX,MY,MB);
  316.  RECTANGLE(MX,MY,MX+XCHAR,MY+YCHAR,255);
  317. END;
  318. {───────────────────────────────────────────────────────────────────────────}
  319. PROCEDURE RELEASEMOUSE; { FREE VGA MOUSE }
  320. BEGIN
  321. END;
  322. {───────────────────────────────────────────────────────────────────────────}
  323. PROCEDURE SHOWMOUSE; { MAKE MOUSE VISIBLE }
  324. BEGIN
  325.  IF MOUSEHIDE=FALSE THEN EXIT;
  326.  MOUSEHIDE:=FALSE;
  327.  MOUSEPOS(OX,OY,MB);
  328.  GETMOUSE(OX,OY,BACKM);
  329.  MX:=OX; MY:=OY;
  330.  RECTANGLE(MX,MY,MX+XCHAR,MY+YCHAR,255);
  331.  DELAY(100);
  332. END;
  333. {───────────────────────────────────────────────────────────────────────────}
  334. PROCEDURE HIDEMOUSE; { MAKE MOUSE INVISIBLE }
  335. BEGIN
  336.  IF MOUSEHIDE THEN EXIT;
  337.  MOUSEHIDE:=TRUE;
  338.  PUTMOUSE(OX,OY,BACKM);
  339.  DELAY(100);
  340. END;
  341. {───────────────────────────────────────────────────────────────────────────}
  342. PROCEDURE MOUSEACTION; { FULL MOUSE MOVE PROCEDURE }
  343. BEGIN
  344.  MB:=0; MOUSEPOS(MX,MY,MB);
  345.  IF MOUSEHIDE=FALSE THEN
  346.  IF (MX<>OX) OR (MY<>OY) THEN
  347.  BEGIN
  348.   PUTMOUSE(OX,OY,BACKM);
  349.   GETMOUSE(MX,MY,BACKM);
  350.   RECTANGLE(MX,MY,MX+XCHAR,MY+YCHAR,255);
  351.  END;
  352.  OX:=MX; OY:=MY;
  353. END;
  354. {───────────────────────────────────────────────────────────────────────────}
  355. FUNCTION CHECK(X1,Y1,X2,Y2: INTEGER): BOOLEAN; { CHECK MOUSE COLLIDE }
  356. BEGIN
  357.  IF (MX>X2) OR (MX<X1) OR (MY<Y1) OR (MY>Y2) THEN CHECK:=FALSE
  358.  ELSE CHECK:=TRUE;
  359. END;
  360. {───────────────────────────────────────────────────────────────────────────}
  361. PROCEDURE TRUESHOW; ASSEMBLER; { SHOW A CORE MOUSE CURSOR }
  362. ASM
  363.  MOV AX,1
  364.  INT 33H
  365. END;
  366. {───────────────────────────────────────────────────────────────────────────}
  367. PROCEDURE TRUEHIDE; ASSEMBLER; { HIDE A CORE MOUSE CURSOR }
  368. ASM
  369.  MOV AX,2
  370.  INT 33H
  371. END;
  372. {───────────────────────────────────────────────────────────────────────────}
  373. PROCEDURE CREATEVIRTUAL; { CREATE VIRTUAL SCREEN IN MEMORY }
  374. BEGIN
  375.  GETMEM(BITMAP,64000);
  376.  FILLCHAR(BITMAP^,64000,0);
  377. END;
  378. {───────────────────────────────────────────────────────────────────────────}
  379. PROCEDURE RELEASEVIRTUAL; { REMOVE VIRTUAL SCREEN IN MEMORY }
  380. BEGIN
  381.  FREEMEM(BITMAP,64000);
  382. END;
  383. {───────────────────────────────────────────────────────────────────────────}
  384. PROCEDURE COPYVIRTUAL; { COPY SCREEN TO ADDRESS 0A000:0 }
  385. BEGIN
  386.  MOVE(BITMAP^,MEM[$A000:0],64000);
  387. END;
  388. {───────────────────────────────────────────────────────────────────────────}
  389. PROCEDURE READCEL(NAME: STRING); { LOAD CEL FROM .CEL AND PALETTE FROM .COL }
  390. VAR F: FILE; NR: BYTE;
  391. BEGIN
  392.  ASSIGN(F,NAME+'.CEL');
  393.  {$I-} RESET(F,1); NR:=IORESULT; {$I+}
  394.  IF NR>0 THEN EXIT;
  395.  SEEK(F,800);
  396.  BLOCKREAD(F,BITMAP^,64000);
  397.  CLOSE(F);
  398.  ASSIGN(F,NAME+'.COL');
  399.  {$I-} RESET(F,1); NR:=IORESULT; {$I+}
  400.  IF NR=0 THEN
  401.  BEGIN
  402.   BLOCKREAD(F,PALETTE,768);
  403.   CLOSE(F);
  404.   FOR NR:=0 TO 255 DO SETCOLOR(NR,PALETTE[NR,1],PALETTE[NR,2],PALETTE[NR,3]);
  405.  END;
  406. END;
  407. {───────────────────────────────────────────────────────────────────────────}
  408. VAR PAL: ARRAY [0..767] OF BYTE;
  409. FUNCTION NEXTPIXEL: INTEGER; FAR;
  410. BEGIN
  411.  INC(X);
  412.  IF X> 64000 THEN NEXTPIXEL:= -1 ELSE NEXTPIXEL := BITMAP^[X-1];
  413. END;
  414. PROCEDURE DUMMY(VAR LINE; X,Y:INTEGER); FAR;
  415. BEGIN
  416.  MOVE(LINE,BITMAP^[X*320],Y);
  417. END;
  418. PROCEDURE READGIF(NAME: STRING);
  419. VAR NR: BYTE;
  420. BEGIN
  421.  X := 0;
  422.  Y := 0;
  423.  GifInPixelProc := NEXTPIXEL;
  424.  GifOutLineProc := DUMMY;
  425.  LOADGIF(NAME+'.GIF');
  426.  MOVE(GIFPALETTE,PALETTE,768);
  427.  FOR NR:=0 TO 255 DO SETCOLOR(NR,PALETTE[NR,1],PALETTE[NR,2],PALETTE[NR,3]);
  428. END;
  429. {───────────────────────────────────────────────────────────────────────────}
  430. PROCEDURE READBMP(NAME: STRING); { LOAD BMP TO MEMORY ( VIRTUAL ) }
  431. VAR B4: ARRAY [1..4] OF BYTE; NR: BYTE; F: FILE; II: INTEGER;
  432. BEGIN
  433.  ASSIGN(F,NAME+'.BMP');
  434.  {$I-} RESET(F,1); NR:=IORESULT; {$I+ }
  435.  IF NR>0 THEN EXIT;
  436.  SEEK(F,54);
  437.  FOR NR:=0 TO 255 DO
  438.  BEGIN
  439.   BLOCKREAD(F,B4,4);
  440.   PALETTE[NR,1]:=B4[3] SHR 2;
  441.   PALETTE[NR,2]:=B4[2] SHR 2;
  442.   PALETTE[NR,3]:=B4[1] SHR 2;
  443.  END;
  444.  FOR II:=199 DOWNTO 0 DO
  445.  BEGIN
  446.   BLOCKREAD(F,BITMAP^[II*320],320);
  447.  END;
  448.  CLOSE(F);
  449.  FOR NR:=0 TO 255 DO SETCOLOR(NR,PALETTE[NR,1],PALETTE[NR,2],PALETTE[NR,3]);
  450. END;
  451. {───────────────────────────────────────────────────────────────────────────}
  452. PROCEDURE INSERTCHAR(CH: CHAR; WSPX,WSPY: INTEGER); { INSERT CHAR TO TABLE }
  453. VAR SIZE: WORD; II: INTEGER;
  454. BEGIN
  455.  SIZE:=XCHAR*YCHAR;
  456.  IF CHARS[CH]=NIL THEN GETMEM(CHARS[CH],SIZE) ELSE
  457.  BEGIN FREEMEM(CHARS[CH],SIZEOF(CHARS[CH]^)); GETMEM(CHARS[CH],SIZE); END;
  458.  FOR II:=WSPY TO WSPY+YCHAR-1 DO
  459.  MOVE(BITMAP^[II*320+WSPX],MEM[SEG(CHARS[CH]^):OFS(CHARS[CH]^)+(II-WSPY)*XCHAR],XCHAR);
  460.  CHARSDATA[CH,1]:=XCHAR;
  461.  CHARSDATA[CH,2]:=YCHAR;
  462.  CHARSDATA[CH,3]:=1;
  463. END;
  464. {───────────────────────────────────────────────────────────────────────────}
  465. PROCEDURE SAVECHARSET(NAME: STRING); { SAVE EDITED FONTS }
  466. VAR F: FILE; CH: CHAR;
  467. BEGIN
  468.  ASSIGN(F,NAME+'.TED');
  469.  REWRITE(F,1);
  470.  BLOCKWRITE(F,HEADER,20);
  471.  FOR CH:=' ' TO ']' DO
  472.  BEGIN
  473.   IF CHARSDATA[CH,3]>0 THEN
  474.   BEGIN
  475.    BLOCKWRITE(F,CH,1);
  476.    BLOCKWRITE(F,CHARSDATA[CH,1],1);
  477.    BLOCKWRITE(F,CHARSDATA[CH,2],1);
  478.    BLOCKWRITE(F,CHARS[CH]^,CHARSDATA[CH,1]*CHARSDATA[CH,2]);
  479.   END;
  480.  END;
  481.  CLOSE(F);
  482. END;
  483. {───────────────────────────────────────────────────────────────────────────}
  484. PROCEDURE SAVECHARSETUP(NAME: STRING); { SAVE EDITED FONTS WITH UPDATE }
  485. VAR F,FF: FILE; CH: CHAR; TMP: ARRAY [1..20] OF BYTE; TMPP: ARRAY [' '..']',1..3] OF BYTE;
  486. BEGIN
  487.  ASSIGN(FF,NAME+'.TE$');
  488.  REWRITE(FF,1);
  489.  ASSIGN(F,NAME+'.TED');
  490.  RESET(F,1);
  491.  BLOCKREAD(F,TMP,20);
  492.  BLOCKWRITE(FF,TMP,20);
  493.  FILLCHAR(TMPP,SIZEOF(TMPP),0);
  494.  WHILE NOT(EOF(F)) DO
  495.  BEGIN
  496.   BLOCKREAD(F,CH,1);
  497.   BLOCKREAD(F,TMPP[CH,1],1);
  498.   BLOCKREAD(F,TMPP[CH,2],1);
  499.   BLOCKREAD(F,TEMP,TMPP[CH,1]*TMPP[CH,2]);
  500.   TMPP[CH,3]:=1;
  501.   BLOCKWRITE(FF,CH,1);
  502.   IF CHARSDATA[CH,3]=1 THEN
  503.   BEGIN
  504.    BLOCKWRITE(FF,CHARSDATA[CH,1],1);
  505.    BLOCKWRITE(FF,CHARSDATA[CH,2],1);
  506.    BLOCKWRITE(FF,CHARS[CH]^,CHARSDATA[CH,1]*CHARSDATA[CH,2]);
  507.   END ELSE
  508.   BEGIN
  509.    BLOCKWRITE(FF,TMPP[CH,1],1);
  510.    BLOCKWRITE(FF,TMPP[CH,2],1);
  511.    BLOCKWRITE(FF,TEMP,TMPP[CH,1]*TMPP[CH,2]);
  512.   END;
  513.  END;
  514.  FOR CH:=' ' TO ']' DO
  515.  BEGIN
  516.   IF (TMPP[CH,3]=0) AND (CHARSDATA[CH,3]=1) THEN
  517.   BEGIN
  518.    BLOCKWRITE(FF,CH,1);
  519.    BLOCKWRITE(FF,CHARSDATA[CH,1],1);
  520.    BLOCKWRITE(FF,CHARSDATA[CH,2],1);
  521.    BLOCKWRITE(FF,CHARS[CH]^,CHARSDATA[CH,1]*CHARSDATA[CH,2]);
  522.   END;
  523.  END;
  524.  CLOSE(FF);
  525.  ERASE(F);
  526.  ASSIGN(FF,NAME+'.TE$');
  527.  RENAME(FF,NAME+'.TED');
  528. END;
  529. {───────────────────────────────────────────────────────────────────────────}
  530. VAR TMPIC : PSCREEN;
  531. PROCEDURE SAVETMP; { CREATE TEMP SCREEN }
  532. BEGIN
  533.  GETMEM(TMPIC,64000);
  534.  MOVE(MEM[$A000:0],TMPIC^,64000);
  535. END;
  536. {───────────────────────────────────────────────────────────────────────────}
  537. PROCEDURE RESTORETMP; { FREE TEMP SCREEN }
  538. BEGIN
  539.  MOVE(TMPIC^,MEM[$A000:0],64000);
  540.  FREEMEM(TMPIC,64000);
  541. END;
  542. {───────────────────────────────────────────────────────────────────────────}
  543. PROCEDURE INSERTPROC(CH: CHAR); { INSERT CHAR INTO CHARSET }
  544. VAR TX,TY,NR,I: BYTE;  ZZ: CHAR; OKI: BOOLEAN;
  545. BEGIN
  546.  IF NOT(CH IN [' '..']']) THEN EXIT;
  547.  HIDEMOUSE;
  548.  SAVETMP;
  549.  FILLCHAR(MEM[$A000:0],64000,0);
  550.  FOR I:=1 TO 20 DO SETCOLOR(231+I,0,0,10+(I*2)-1);
  551.  SETCOLOR(230,35,40,44);
  552.  FOR I:=0 TO 19 DO
  553.   FILLCHAR(MEM[$A000:I*320],320,232+I);
  554.  WRITEXY('ADD CHAR '+CH+' TO FONT? (Y/N) ',5,2,230);
  555.  RECTANGLE2(50,60,50+XCHAR+1,60+YCHAR+1,230);
  556.  FOR TY := 1 TO YCHAR DO
  557.  FOR TX := 1 TO XCHAR DO
  558.   MEM[$A000:(60+TY)*320+50+TX]:=BITMAP^[(MY+TY-1)*320+MX+TX-1];
  559.  STR(XCHAR,S);
  560.  STR(YCHAR,N);
  561.  S:='X  - '+S;
  562.  N:='Y  - '+N;
  563.  WRITEXY(S,200,50,230);
  564.  WRITEXY(N,200,70,230);
  565.  STR(ORD(CH),N);
  566.  S:='NR - '+N;
  567.  WRITEXY(S,200,90,230);
  568.  DELAY(100);
  569.  ZZ:=UPCASE(READKEY);
  570.  CASE ZZ OF
  571.   'Y' : OKI:=TRUE
  572.   ELSE OKI:=FALSE;
  573.  END;
  574.  RESTORETMP;
  575.  FOR NR:=0 TO 255 DO SETCOLOR(NR,PALETTE[NR,1],PALETTE[NR,2],PALETTE[NR,3]);
  576.  IF OKI THEN INSERTCHAR(CH,MX,MY);
  577.  SHOWMOUSE;
  578. END;
  579. {───────────────────────────────────────────────────────────────────────────}
  580. PROCEDURE SAVEMENU; { SAVE FONT FILE TO DISK }
  581. VAR NR: BYTE; I: INTEGER; NAME: STRING; CH,WW: CHAR; F: FILE;
  582. LABEL LONGJUMP;
  583. BEGIN
  584.  HIDEMOUSE;
  585.  SAVETMP;
  586.  FILLCHAR(MEM[$A000:0],64000,0);
  587.  DELAY(100);
  588.  FOR I:=1 TO 20 DO SETCOLOR(231+I,0,0,10+(I*2)-1);
  589.  SETCOLOR(230,35,40,44);
  590.  FOR I:=0 TO 19 DO
  591.   FILLCHAR(MEM[$A000:I*320],320,232+I);
  592.  WRITEXY('SAVE FONT',115,2,230);
  593.  SETCOLOR(255,255,255,0);
  594.  WRITEXY('SELECT: (320x200x256)',10,40,255);
  595.  WRITEXY(' 1 - SAVE TED&PAL',10,60,255);
  596.  WRITEXY(' 2 - UPDATE TED FILE',10,80,255);
  597.  WRITEXY(' 0 - ABORT ',10,100,255);
  598.  WW:=UPCASE(READKEY);
  599.  IF WW='0' THEN GOTO LONGJUMP;
  600.  IF NOT(WW IN ['1','2']) THEN WW:='1';
  601.  WRITEXY('ENTER NAME (NO EXTENSION)',20,120,255);
  602.  GOTOXY(13,18); READLN(NAME);
  603.  WRITEXY('ARE YOU SURE?',30,160,255);
  604.  CH:=UPCASE(READKEY);
  605.  IF CH='Y' THEN
  606.  BEGIN
  607.   CASE WW OF
  608.    '1': BEGIN
  609.          ASSIGN(F,NAME+'.PAL');
  610.          REWRITE(F,1);
  611.          BLOCKWRITE(F,PALETTE,768);
  612.          CLOSE(F);
  613.          SAVECHARSET(NAME);
  614.         END;
  615.    '2': BEGIN
  616.          SAVECHARSETUP(NAME);
  617.         END;
  618.   END;
  619.   WRITEXY('SAVED...',80,180,255);
  620.   DELAY(500);
  621.  END;
  622. LONGJUMP:
  623.  RESTORETMP;
  624.  FOR NR:=0 TO 255 DO SETCOLOR(NR,PALETTE[NR,1],PALETTE[NR,2],PALETTE[NR,3]);
  625.  SHOWMOUSE;
  626. END;
  627. {───────────────────────────────────────────────────────────────────────────}
  628. PROCEDURE LOADMENU; { LOAD GFX FILE 320X200X256 FROM DISK TO MEMORY }
  629. VAR NR: BYTE; I: INTEGER; CH: CHAR; NAME: STRING;
  630. LABEL LONGJUMP;
  631. BEGIN
  632.  HIDEMOUSE;
  633.  SAVETMP;
  634.  FILLCHAR(MEM[$A000:0],64000,0);
  635.  DELAY(100);
  636.  FOR I:=1 TO 20 DO SETCOLOR(231+I,0,0,10+(I*2)-1);
  637.  SETCOLOR(230,35,40,44);
  638.  FOR I:=0 TO 19 DO
  639.   FILLCHAR(MEM[$A000:I*320],320,232+I);
  640.  WRITEXY('LOAD GFX',110,2,230);
  641.  SETCOLOR(255,255,255,0);
  642.  WRITEXY('SELECT: (320x200x256)',10,40,255);
  643.  WRITEXY(' 1 - LOAD GIF ',10,60,255);
  644.  WRITEXY(' 2 - LOAD CEL & COL ',10,80,255);
  645.  WRITEXY(' 3 - LOAD BMP ',10,100,255);
  646.  WRITEXY(' 0 - ABORT ',10,120,255);
  647.  CH:=UPCASE(READKEY);
  648.  IF (CH IN ['1','2','3']) THEN
  649.  BEGIN
  650.   WRITEXY('ENTER NAME (NO EXTENSION)',10,150,255);
  651.   GOTOXY(8,23);
  652.   READLN(NAME);
  653.   RESTORETMP;
  654.   FOR NR:=0 TO 255 DO SETCOLOR(NR,PALETTE[NR,1],PALETTE[NR,2],PALETTE[NR,3]);
  655.   CASE CH OF
  656.    '1': READGIF(NAME);
  657.    '2': READCEL(NAME);
  658.    '3': READBMP(NAME);
  659.   END;
  660.   MOVE(BITMAP^,MEM[$A000:0],64000);
  661.   SHOWMOUSE;
  662.   GOTO LONGJUMP;
  663.  END;
  664.  RESTORETMP;
  665.  FOR NR:=0 TO 255 DO SETCOLOR(NR,PALETTE[NR,1],PALETTE[NR,2],PALETTE[NR,3]);
  666.  SHOWMOUSE;
  667. LONGJUMP:
  668. END;
  669. {───────────────────────────────────────────────────────────────────────────}
  670. PROCEDURE HELP; { HELP!!! }
  671. VAR NR: BYTE; I: INTEGER;
  672. BEGIN
  673.  HIDEMOUSE;
  674.  SAVETMP;
  675.  FILLCHAR(MEM[$A000:0],64000,0);
  676.  DELAY(100);
  677.  FOR I:= 0 TO 63 DO SETCOLOR(190+I,I,0,0);
  678.  FOR I:= 0 TO 63 DO
  679.  FILLCHAR(MEM[$A000:(I+1)*320*3],960,190+I);
  680.  SETCOLOR(255,30,30,30);
  681.  SETCOLOR(254,0,255,0);
  682.  WRITEXY('A FEW HOURS OF CODE',65,20,255);
  683.  WRITEXY('TED - FONT EDITOR V1.0',50,10,254);
  684.  WRITEXY('CODED BY PARADiSE ''94',54,27,254);
  685.  WRITEXY('HOT KEYS:',10,60,255);
  686.  WRITEXY('F1- HELP      F2- SAVE FONT',10,80,255);
  687.  WRITEXY('F3- LOAD GFX  F4- LIGHT MOUSE',10,100,255);
  688.  WRITEXY('ALTX- EXIT',10,120,255);
  689.  WRITEXY('',10,140,255);
  690.  WRITEXY('IF U HAVE AND IDEAS CALL ME :',10,160,255);
  691.  WRITEXY('LIKSAY@BACHUS.UMCS.LUBLIN.PL',20,180,254);
  692.  READKEY;
  693.  RESTORETMP;
  694.  FOR NR:=0 TO 255 DO SETCOLOR(NR,PALETTE[NR,1],PALETTE[NR,2],PALETTE[NR,3]);
  695.  SHOWMOUSE;
  696. END;
  697. {───────────────────────────────────────────────────────────────────────────}
  698.  
  699.  
  700.  
  701.  
  702. BEGIN  { MAIN PROGRAM }
  703.  MOUSE:=ISMOUSE;
  704.  INITVGA;
  705.  LOADFONT;
  706.  QUIT:=FALSE;
  707.  XCHAR:=19; YCHAR:=19;
  708.  MMX:=XCHAR+2; MMY:=YCHAR+2;
  709.  CREATEVIRTUAL;
  710.  READGIF('TITLE');
  711.  COPYVIRTUAL;
  712.  READKEY;
  713.  FILLCHAR(MEM[$A000:0],64000,0);
  714.  FILLCHAR(BITMAP^,64000,0);
  715.  SETCOLOR(255,255,255,255);
  716.  WRITEXY('PRESS F3 TO LOAD GFX',50,50,255);
  717.  DELAY(1000);
  718.  SETUPMOUSE;
  719.  REPEAT
  720.   KEY:=0;
  721.   WHILE KEYPRESSED DO
  722.   BEGIN
  723.    KEY:=GETKEY;
  724.    CASE KEY OF
  725.     LEFTK : BEGIN { - X }
  726.              PUTMOUSE(MX,MY,BACKM);
  727.              DEC(XCHAR);
  728.              DEC(MMX);
  729.              GETMOUSE(MX,MY,BACKM);
  730.              RECTANGLE(MX,MY,MX+XCHAR,MY+YCHAR,255);
  731.             END;
  732.     RIGHTK: BEGIN { + X }
  733.              PUTMOUSE(MX,MY,BACKM);
  734.              INC(XCHAR);
  735.              INC(MMX);
  736.              GETMOUSE(MX,MY,BACKM);
  737.              RECTANGLE(MX,MY,MX+XCHAR,MY+YCHAR,255);
  738.             END;
  739.     UPK   : BEGIN { - Y }
  740.              PUTMOUSE(MX,MY,BACKM);
  741.              DEC(YCHAR);
  742.              DEC(MMY);
  743.              GETMOUSE(MX,MY,BACKM);
  744.              RECTANGLE(MX,MY,MX+XCHAR,MY+YCHAR,255);
  745.             END;
  746.     DOWNK : BEGIN { + Y }
  747.              PUTMOUSE(MX,MY,BACKM);
  748.              INC(YCHAR);
  749.              INC(MMY);
  750.              GETMOUSE(MX,MY,BACKM);
  751.              RECTANGLE(MX,MY,MX+XCHAR,MY+YCHAR,255);
  752.             END;
  753.     F1    : HELP;
  754.     F2    : SAVEMENU;
  755.     F3    : LOADMENU;
  756.     F4    : SETCOLOR(255,255,255,255);
  757.     ALTX  : QUIT := TRUE;
  758.     ELSE INSERTPROC(LASTCH);
  759.    END;
  760.    SETCOLOR(255,255,255,255);
  761.   END;
  762.   MOUSEACTION;
  763.  UNTIL QUIT;
  764.  
  765.  RELEASEVIRTUAL;
  766.  CLOSEVGA;
  767. END.
  768.